Best of www.BestZips.com (Collector's Edition)/Best of WWW.BESTZIPS.COM Collector's Edition (JCSM Shareware) (JCS Marketing).ISO/tutorial/adatu311.zip/VAX.ADA

Text File | 1996-01-10 | 5KB | 118 lines

-- VAX.ADA   Ver. 3.11   10-JAN-1996   Copyright 1988-1996 John J. Herro
--
-- SOFTWARE INNOVATIONS TECHNOLOGY          http://members.aol.com/AdaTutor
-- 1083 MANDARIN DR NE                      ftp://members.aol.com/AdaTutor
-- PALM BAY FL 32905-4706
--                                          [e-mail]
-- [phone]                           [e-mail]
--
-- Compile this before compiling ADA_TUTR.ADA with VAX Ada.  See the first page
-- of ADA_TUTR.ADA for more details.
--
package Custom_IO is
   type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White);
   Foregrnd_Color   : Color := White;                 -- Default values in case
   Backgrnd_Color   : Color := Black;                 -- ADA-TUTR finds no User
   Border_Color     : Color := Black;                 -- File.
   Fore_Color_Digit : Character := Character'Val(Color'Pos(Foregrnd_Color)+48);
   Back_Color_Digit : Character := Character'Val(Color'Pos(Backgrnd_Color)+48);
   Normal_Colors    : String(1 .. 10) := ASCII.ESC & "[0;3" &
                              Fore_Color_Digit & ";4" & Back_Color_Digit & "m";
   Clear_Scrn       : constant String := ASCII.ESC & "[H" & ASCII.ESC & "[2J";

   procedure Set_Border_Color (To   : in  Color);
   procedure Get              (Char : out Character);
   procedure Put              (Char : in  Character);
   procedure Put              (Str  : in  String);
   procedure Put_Line         (Str  : in  String);
   procedure Get_Line         (Str  : out String; Last : out Natural);
   procedure New_Line;
end Custom_IO;

with Starlet, System; use Starlet, System;
package body Custom_IO is
   Chan : Starlet.Channel_Type;
   IOSB : System.Unsigned_Quadword;
   Stat : System.Unsigned_Longword;
   procedure QIOW(Stat : out Unsigned_Longword; EFN : in Integer;
        Chan : in Channel_Type; Func : in Short_Integer;
        IOSB : out Unsigned_Quadword; ASTadr : in Integer; ASTPRM : in Integer;
        P1 : in out String; P2, P3 : in Integer; P4 : in Unsigned_Quadword;
        P5, P6 : in Integer);                   -- Pragma Interface is used for
   pragma Interface(System_Library, QIOW);      -- compatibility with Ada 83.
   pragma Import_Valued_Procedure(Internal => QIOW, External => "SYS$QIOW",
        Parameter_Types => (Unsigned_Longword, Integer, Channel_Type,
             Short_Integer, Unsigned_Quadword, Integer, Integer, String,
             Integer, Integer, Unsigned_Quadword, Integer, Integer),
        Mechanism => (Value, Value, Value, Value, Reference, Value, Reference,
             Reference, Value, Reference, Reference, Reference, Reference));

   procedure Set_Border_Color(To : in Color) is
      -- Dummy procedure for computers other than PCs.
   begin
      null;
   end Set_Border_Color;

   procedure Get(Char : out Character) is
      S : String(1 .. 1);
   begin
      QIOW(Stat, 0, Chan, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
      Char := S(1);
   end Get;

   procedure Put(Char : in Character) is
   begin
      Put(Char & "");
   end PUT;

   procedure Put(Str : in String) is
      S : String(Str'Range) := Str;
   begin
      QIOW(Stat, 0, Chan, 16#70#, IOSB, 0, 0, S, S'Length, 0, (0,0), 0, 0);
   end PUT;

   procedure Put_Line(Str : in String) is
   begin
      Put(Str & ASCII.CR & ASCII.LF);
   end Put_Line;

   procedure Get_Line(Str : out String; Last : out Natural) is separate;

   procedure New_Line is
   begin
      Put(ASCII.CR & ASCII.LF);
   end New_Line;
begin
   Starlet.Assign(Stat, "TT:", Chan);
end Custom_IO;

-- This procedure gets a string from the terminal, while allowing typing errors
-- to be corrected.
--
separate (Custom_IO)
procedure Get_Line(Str : out String; Last : out Natural) is
   S     : String(Str'Range);                             -- Local copy of Str.
   Char  : Character := ' ';                    -- One character from keyboard.
   Place : Integer   := Str'First;     -- Position of next available character.
begin
   while Char /= ASCII.CR loop                   -- CR signifies end of string.
      Get(Char);                                          -- Get one character.
      if Char = ASCII.CR then
         New_Line;                       -- Give new line at end of the string.
      elsif Char = ASCII.BS or Char = ASCII.DEL then
         if Place > Str'First then        -- Ignore BS/DEL when string is null.
            Put(ASCII.BS & ' ' & ASCII.BS);   -- Erase last char. from display.
            Place := Place - 1;               -- Remove last char. from string.
         end if;
      elsif Place > Str'Last then    -- Beep when length of string is exceeded.
         Put(ASCII.BEL);
      else
         Put(Char);                                -- Echo the character typed.
         S(Place) := Char;                      -- Add character to the string.
         Place := Place + 1;
      end if;
   end loop;
   Str(Str'First .. Place - 1) := S(Str'First .. Place - 1);
   Last := Place - 1;
end Get_Line;